Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue59/System/TarUnit.pas

Pascal/Delphi Source File | 2000-06-08 | 7.3 KB | 239 lines

unit TarUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    Files: TListView;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    Label1: TLabel;
    SaveDialog1: TSaveDialog;
    procedure FilesDblClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
    TTarFileEntry = class (TObject)
    private
        name, uid, gid: String;
        mode, size: Integer;
        mtime: TDateTime;
        FileOffset: Integer;
    end;

    TTarFile = class (TObject)
    private
        FileList: TStringList;
    public
        constructor Create (const FileName: String);
        destructor Destroy; override;
    end;

// TTarFile

function OctalToInt (Str: String): Integer;
var
    Idx: Integer;
begin
    Result := 0;  Str := Trim (Str);
    for Idx := 1 to Length (Str) do begin
        if not (Str [Idx] in ['0'..'7']) then Exit;
        Result := (Result shl 3) + Ord (Str [Idx]) - Ord ('0');
    end;
end;

function UnixTimeToFileTime (UnixDateTime: TLargeInteger): TDateTime;
var
    Time: Integer;
    LocalTime: TFileTime;
    FileTime: TFileTime absolute UnixDateTime;
begin
    UnixDateTime := (UnixDateTime + 11644473600) * 10000000;
    FileTimeToLocalFileTime (FileTime, LocalTime);                           // WIN32!!
    FileTimeToDosDateTime (LocalTime, LongRec (Time).Hi, LongRec (Time).Lo); // WIN32!!
    Result := FileDateToDateTime (Time);
end;

function PermissionsToStr (Perm: Integer): String;

    function PermFlags (bits: Integer): String;
    begin
        Result := '---';
        if (bits and 4) <> 0 then Result [1] := 'r';
        if (bits and 2) <> 0 then Result [2] := 'w';
        if (bits and 1) <> 0 then Result [3] := 'x';
    end;

begin
    // Display order is owner-group-other
    Result := PermFlags (Perm shr 6) + PermFlags (Perm shr 3) + PermFlags (Perm);
end;

constructor TTarFile.Create (const FileName: String);
type
    TarHeader = record
        name: array [0..99] of Char;            // name of the file
        mode: array [0..7] of Char;             // permission bits
        uid: array [0..7] of Char;              // owner - user ID
        gid: array [0..7] of Char;              // owner - group ID
        size: array [0..11] of Char;            // size of this file
        mtime: array [0..11] of Char;           // file modification time
        chksum: array [0..7] of Char;           // checksum for file header
        linkflag: Char;
        linkname: array [0..99] of Char;
        magic: array [0..7] of Char;
        uname: array [0..31] of Char;
        gname: array [0..31] of Char;
        devmajor: array [0..7] of Char;
        devminor: array [0..7] of Char;
    end;

var
    fs: TFileStream;
    Header: TarHeader;
    NextBlock: Integer;
    entry: TTarFileEntry;
begin
    Inherited Create;
    FileList := TStringList.Create;
    if FileExists (FileName) then begin
        fs := TFileStream.Create (FileName, fmOpenRead);
        try
            while fs.Position < fs.Size do begin
                NextBlock := fs.Position + 512;
                fs.Read (Header, sizeof (Header));
                if Header.name = '' then break;

                entry := TTarFileEntry.Create;
                entry.name  := Header.name;
                entry.mode  := OctalToInt (Header.mode);
                entry.size  := OctalToInt (Header.size);
                entry.mtime := UnixTimeToFileTime (OctalToInt (Header.mtime));
                entry.FileOffset := NextBlock;

                if Trim (Header.magic) = 'ustar' then begin
                    entry.uid   := Trim (Header.uname);
                    entry.gid   := Trim (Header.gname);
                end else begin
                    entry.uid   := Trim (Header.uid);
                    entry.gid   := Trim (Header.gid);
                end;

                FileList.AddObject (entry.name, entry);

                fs.Position := NextBlock + ((entry.size + 511) div 512) * 512;
            end;
        finally
            fs.Free;
        end;
    end;
end;

destructor TTarFile.Destroy;
var
    Idx: Integer;
begin
    for Idx := FileList.Count - 1 downto 0 do
        FileList.Objects [Idx].Free;
    FileList.Free;
    Inherited Destroy;
end;

procedure TForm1.FilesDblClick(Sender: TObject);
var
    Item: TListItem;
    FileName: String;
    Size, Offset: Integer;

    function DeUnix (const Path: String): String;
    var
        Idx: Integer;
    begin
        Result := Path;
        for Idx := 1 to Length (Result) do
            if Result [Idx] = '/' then Result [Idx] := '\';
    end;

    procedure ExtractFile (const Archive, Dest: String; Offset, Size: Integer);
    var
        sArchive, sDest: TFileStream;
    begin
        sArchive := TFileStream.Create (Archive, fmOpenRead);
        try
            sDest := TFileStream.Create (Dest, fmCreate);
            try
                sArchive.Position := Offset;
                sDest.CopyFrom (sArchive, Size);
            finally
                sDest.Free;
            end;
        finally
            sArchive.Free;
        end;
    end;

begin
    if Files.Items.Count = 0 then ShowMessage ('Please open a tar file first') else begin
        Item := Files.Selected;
        if Item <> Nil then begin
            Size := StrToInt (Item.SubItems [2]);
            if Size = 0 then ShowMessage ('Can only extract physical files') else begin
                Offset := StrToInt (Item.SubItems [6]);
                FileName := ExtractFileName (DeUnix (Item.Caption));
                if MessageDlg ('Extract ' + FileName + '?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
                    SaveDialog1.FileName := FileName;
                    if SaveDialog1.Execute then ExtractFile (OpenDialog1.FileName, SaveDialog1.FileName, Offset, Size);
                end;
            end;
        end;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
    Idx: Integer;
    tar: TTarFile;
    Item: TListItem;
    Entry: TTarFileEntry;
begin
    if OpenDialog1.Execute then begin
        tar := TTarFile.Create (OpenDialog1.FileName);
        try
            Files.Items.Clear;
            for Idx := 0 to tar.FileList.Count - 1 do begin
                Entry := TTarFileEntry (tar.FileList.Objects [Idx]);
                Item := Files.Items.Add;
                Item.Caption := Entry.name;
                Item.SubItems.Add (FormatDateTime ('dd/mm/yyyy', Entry.mtime));
                Item.SubItems.Add (FormatDateTime ('hh:mm:ss', Entry.mtime));
                Item.SubItems.Add (IntToStr (Entry.size));
                Item.SubItems.Add (PermissionsToStr (Entry.mode));
                Item.SubItems.Add (Entry.uid);
                Item.SubItems.Add (Entry.gid);
                if Entry.size <> 0 then Item.SubItems.Add ('$' + IntToHex (Entry.FileOffset, 8));
            end;
        finally
            tar.Free;
            Label1.Visible := Files.Items.Count > 0;
        end;
    end;
end;

end.